﻿module BoardTool.Transmute

open System
open System.Collections.Generic

open BoardTool.Tool
open BoardTool.Commands
open BoardTool.Board
open BoardTool.DirTree

// Syntax:
// Line ::= Comment | Rule
// Comment ::= '#' <anything till the end of line>
// Rule ::= RuleName '=' Matchers '->' Replacements
// Matchers ::= TerrainMatcher ';' ... ';' TerrainMatcher
// TerrainMatcher ::= TerrainType [':' ParamMatcher [':' ParamMatcher] ]
// ParamMatcher ::= VarName ['?' ([min] '..' [max] | value) ]
// Replacements ::= TerrainReplacement ';' ... ';' TerrainReplacement
// TerrainReplacement ::= TerrainType [':' ParamReplacement [':' ParamReplacement] ]
// ParamReplacement ::= value | '$' VarName

module private TM =
    type Matcher = TerrainMatcher list
    and TerrainMatcher =
        {
        Type : string
        LevelMatcher : ParamMatcher option
        ExitsMatcher : ParamMatcher option
        }
    and ParamMatcher =
        {
        VarName : string
        LowBound : int option
        HighBound : int option
        }

    let mkParamMatcher varName lowBound highBound =
        { VarName = varName; LowBound = lowBound; HighBound = highBound }

    let mkTerrainMatcher ttype lvlMatcher exMatcher =
        { Type = ttype; LevelMatcher = lvlMatcher; ExitsMatcher = exMatcher }

    type Replacement = TerrainReplacement list
    and TerrainReplacement =
        {
        Type : string
        LevelRepl : ParamReplacement option
        ExitsRepl : ParamReplacement option
        }
    and ParamReplacement =
        | Num of int
        | Var of string

    let mkTerrainRepl ttype lvRepl exRepl =
        { Type = ttype; LevelRepl = lvRepl; ExitsRepl = exRepl }

    let mkVarRepl varName = ParamReplacement.Var varName
    let mkNumRepl value = ParamReplacement.Num value

    type Rule = 
        {
        Name : string
        Matcher : Matcher
        Replacement : Replacement
        }

    let mkRule name mr repl =
        { Name = name; Matcher = mr; Replacement = repl }

    type Script = Rule list
        
    let private matchAgainst (m : Matcher) (tt : TerrainTable) =
        let applyNumMatcher (nmOpt : ParamMatcher option) (valueOpt : int option) accVars =
            match nmOpt, valueOpt with
            | Some nm, Some value ->
                if (Option.isNone nm.HighBound || value <= Option.get nm.HighBound) &&
                    (Option.isNone nm.LowBound || value >= Option.get nm.LowBound)
                then
                    Some <| if nm.VarName <> "_" then (nm.VarName, value) :: accVars else accVars
                else
                    None
            | Some _, None ->
                None
            | None, _ -> 
                Some accVars            
        
        let rec matchRec (tms : TerrainMatcher list) (accVars : (string * int) list) =
            match tms with
            | tm :: tms' ->
                match tt.TryGet( tm.Type ) with
                | Some te ->
                    match applyNumMatcher tm.LevelMatcher (Some te.Level) accVars with
                    | Some accVars ->
                        match applyNumMatcher tm.ExitsMatcher te.Exits accVars with
                        | Some accVars ->
                            matchRec tms' accVars
                        | None -> None
                    | None -> None
                | None -> None
            | [] -> Some accVars    
                            
        matchRec m [] |> Option.map dict

    let private makeTerrainFromReplacement (tr : TerrainReplacement) (vars : IDictionary<string, int>) (tt : TerrainTable) =
        let getVar varName =
            let hasVar, value = vars.TryGetValue( varName )
            if hasVar then
                value
            else
                failwith "Undefined variable in replacement: '%s'" varName
            
        let level =
            match tr.LevelRepl with
            | Some( Var varName ) ->
                getVar varName
            | Some( Num value ) ->
                value
            | None ->
                match tt.TryGet( tr.Type ) with
                | Some te -> te.Level
                | None -> failwith "No terrain level in replacement for '%s'" tr.Type
        
        let exits =
            match tr.ExitsRepl with
            | None -> None
            | Some( Num value ) -> Some value
            | Some( Var varName ) -> Some <| getVar varName

        { Type = tr.Type; Level = level; Exits = exits }
        
    let private applyReplacements (matchers : Matcher) (replacements : Replacement) vars (tt : TerrainTable) =
        for m in matchers do 
            tt.Remove( m.Type )
        for tr in replacements do 
            tt.Add <| makeTerrainFromReplacement tr vars tt

    let private applyToTerrainTable (tm : Rule) (tt : TerrainTable) =
        let matchers = tm.Matcher
        let replacements = tm.Replacement
                
        match matchAgainst matchers tt with
        | None -> false            
        | Some vars ->
            applyReplacements matchers replacements vars tt
            true

    let applyToHex (script : Script) (hex : Hex) =
        let tt = TerrainTable( hex.Terrains )
        tt.Add( mkTerrainWithLevel "elevation" hex.Elevation )

        let ruleNamesFired = ResizeArray()

        for rule in script do
            if applyToTerrainTable rule tt then
                ruleNamesFired.Add( rule.Name )

        let elevation' = 
            match tt.TryGet( "elevation" ) with
            | Some elev -> 
                tt.Remove( "elevation" )
                elev.Level
            | None -> hex.Elevation

        let terrains' = tt.TerrainEntries |> Seq.toList

        if ruleNamesFired.Count > 0 then
            let hex' = { hex with Elevation = elevation'; Terrains = terrains' }
            let ruleNamesFired = ruleNamesFired |> Seq.toList
            hex', ruleNamesFired
        else
            hex, []

module private Parser =
    let private RULENAME_BODY_SEP = "="
    let private MATCHER_REPLACEMENT_SEP = "->"
    let private TERRAIN_PARAMS_SEP_CHARS = [| ':' |]
    let private TERRAIN_LIST_SEP_CHARS = [| ';' |]
    let private VAR_BOUNDS_SEP = "?"
    let private LOW_HIGH_SEP = ".."
        
    let private split2 (splitter : string) (str : string) =
        let index = str.IndexOf( splitter )
        if index < 0 then None
        else Some( str.Substring( 0, index ), str.Substring( index + splitter.Length ) )

    let private splitTrimmedList (chars : char[]) (str : string) =
        str.Split( chars )
        |> Array.toList
        |> List.map (fun s -> s.Trim())
        |> List.filter (fun s -> s.Length > 0)

    let private parseNumMatcher (str : string) =
        match split2 VAR_BOUNDS_SEP str with
        | Some (varName, bounds) ->
            let lowBound, highBound =
                match split2 LOW_HIGH_SEP bounds with
                | Some( lowStr, highStr ) ->
                    let lowStr = lowStr.Trim()
                    let highStr = highStr.Trim()
                    let lowBound = if lowStr = "" then None else Some <| int(lowStr)
                    let highBound = if highStr = "" then None else Some <| int(highStr)
                    lowBound, highBound
                | None ->
                    let valStr = bounds.Trim()
                    if valStr = "" then 
                        None, None
                    else
                        let value = int(valStr)
                        Some value, Some value
            TM.mkParamMatcher varName lowBound highBound
        | None ->
            let varName = str.Trim()
            TM.mkParamMatcher varName None None
        
    let private parseTerrainMatcher (tmstr : string) =
        let parts = tmstr.Split( TERRAIN_PARAMS_SEP_CHARS )
        if parts.Length = 0 then    
            failwith "bad terrain matcher: '%s'" tmstr
        
        let ttype = parts.[0].Trim()
        
        let levelMatcher = 
            if parts.Length >= 2 then
                Some <| parseNumMatcher parts.[1]
            else
                None

        let exitsMatcher =
            if parts.Length >= 3 then
                Some <| parseNumMatcher parts.[2]
            else
                None

        TM.mkTerrainMatcher ttype levelMatcher exitsMatcher 

    let private parseNumRepl (nrstr : string) =
        let nrstr = nrstr.Trim()
        if nrstr.Length = 0 then
            failwith "Bad terrain param replacement: '%s'" nrstr

        if nrstr.[0] = '$' then
            TM.mkVarRepl <| nrstr.Substring( 1 )
        else
            TM.mkNumRepl <| int(nrstr)

    let private parseTerrainReplacement (trstr : string) =
        let parts = trstr.Split( TERRAIN_PARAMS_SEP_CHARS )
        if parts.Length = 0 then
            failwith "bad terrain replacement: '%s'" trstr

        let ttype = parts.[0].Trim()

        let levelsRepl =
            if parts.Length >= 2 then
                Some <| parseNumRepl parts.[1]
            else 
                None

        let exitsRepl =
            if parts.Length >= 3 then
                Some <| parseNumRepl parts.[2]
            else
                None

        TM.mkTerrainRepl ttype levelsRepl exitsRepl

    let private parseMatcher (mstr : string) =
        mstr
        |> splitTrimmedList TERRAIN_LIST_SEP_CHARS
        |> List.map parseTerrainMatcher

    let private parseReplacement (rstr : string) =
        rstr
        |> splitTrimmedList TERRAIN_LIST_SEP_CHARS
        |> List.map parseTerrainReplacement

    let private parseRule (line : string ) : TM.Rule =
        match split2 RULENAME_BODY_SEP line with
        | Some( name, body ) ->
            match split2 MATCHER_REPLACEMENT_SEP body with
            | Some( matcherStr, replacementStr ) ->
                let matcher = parseMatcher matcherStr
                let replacement = parseReplacement replacementStr
                TM.mkRule name matcher replacement
            | None ->
                failwith "missing '%s' in rule body (%s)" MATCHER_REPLACEMENT_SEP body
        | None ->
            failwith "missing rule in line '%s'" line

    let private parseScriptLines (lines : string[]) =
        let rules = ResizeArray()

        let mutable errors = 0

        for line in lines do
            let line = line.Trim()
            if line = "" || line.[0] = '#' then
                () // Skip comments and empty lines
            else
                try 
                    let tr = parseRule line
                    rules .Add( tr )
                with 
                | e -> 
                    eprintfn "Syntax error in line '%s':\n\t'%s'" line e.Message
                    errors <- errors + 1
                
        let rules : TM.Script = rules |> Seq.toList
        rules, errors

    let parseScriptFile (file : string) =
        use rd = new IO.StreamReader( file )
        rd.ReadToEnd().Split( [| '\n' |] )
        |> parseScriptLines

[<CommandOptions( [| "SCRIPT"; "SRCDIR"; "DESTDIR" |], [| "-postfix" |] )>]
type TransmuteArgs =
    {
    [<PositionalOption( "SCRIPT", "script file" )>]
    mutable Script : string
    [<PositionalOption( "SRCDIR", "source directory" )>]
    mutable SrcDir : string
    [<PositionalOption( "DESTDIR", "destination directory" )>]
    mutable DestDir : string
    [<NamedOption( "-postfix", "POSTFIX", "transmuted file postfix (default: '-tm')" )>]
    mutable FilePostfix : string
    }    

let private DEFAULT_TRANSMUTE_ARGS =
    { Script = ""; SrcDir = ""; DestDir = ""; FilePostfix = "-tm" }

type TransmuteResult =
    {
    SrcFile : string
    DestFile : string
    Log : string
    }

type private TransmuteCommand( args : TransmuteArgs ) =
    inherit TransformDirCommand<TransmuteResult>( args.SrcDir, args.DestDir )

    let rules = 
        let rules, errors = Parser.parseScriptFile args.Script
        if errors > 0 then
            failwithf "Script '%s': %d parsing errors" args.Script errors
        rules

    override this.Id = 
        sprintf "(transmute %s %s %s)" args.Script args.SrcDir args.DestDir

    override this.transformFile srcFile destFile =
        let destFile = getPostfixedFile args.FilePostfix destFile

        let logWriter = new IO.StringWriter() 

        fprintfn logWriter "%s -> %s" srcFile destFile

        srcFile
        |> parseBoardFile
        |> Array.map (mapHex 
            (fun hex -> 
                let hex', rulesApplied = TM.applyToHex rules hex
                if not <| List.isEmpty rulesApplied then
                    fprintfn logWriter "  %s: Applied rules %s" 
                        (unparseHex hex)
                        (rulesApplied |> String.concat ", ")
                hex'
            ))
        |> unparseBoardFile destFile

        { SrcFile = srcFile; DestFile = destFile; Log = logWriter.ToString() }

    override this.reduce results =
        for res in results.Values do
            printfn "%s" res.Log

let TRANSMUTE_COMMAND_FACTORY =
    { new ReflectionCommandFactory<TransmuteArgs>( 
            "transmute", "(EXPERIMENTAL) applies transformation script to all boards" 
            ) with
        override this.initArgs() = 
            DEFAULT_TRANSMUTE_ARGS
        override this.createCommand( args ) =
            TransmuteCommand( args ) :> ICommand
    }